﻿(*   Copyright 2011 Alexander Omelchuk
 *
 *   Licensed under the Apache License, Version 2.0 (the "License");
 *   you may not use this file except in compliance with the License.
 *   You may obtain a copy of the License at
 *
 *       http://www.apache.org/licenses/LICENSE-2.0
 *
 *   Unless required by applicable law or agreed to in writing, software
 *   distributed under the License is distributed on an "AS IS" BASIS,
 *   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 *   See the License for the specific language governing permissions and
 *   limitations under the License.
 *)

namespace Lisp

[<AutoOpen>]
module InitEnvironment =
  open System
  open System.Linq.Expressions
  open EvalHelpers
  open SpecialOps

  let specialOp name lambda = GEnvironment.Functions.Add(name, SpecialOp lambda)

  let nativeFunction<'a> name (argsString:string) =
    let passDEnv = typeof<'a>.GetGenericArguments().[0] = typeof<IDynamicEnvironment>
    GEnvironment.CreateFunction
      name
      (argsString.Split(' ') |> Seq.map (fun x -> Id x) |> ofSeq |> getLambdaList passDEnv,
       Delegate.CreateDelegate(typeof<'a>, typeof<NativeFunctions>, name, false))

  let constant name value = GEnvironment.CreateConstant name (Expression.Constant(value, typeof<SExpr>))

//  let inline foldBinary name x xs =
//    fold (fun s y -> Dynamic.ApplyBinaryOp(name, s, unboxVal y))
//         (unboxVal x)
//         xs
//  
//  let inline foldBinaryBool name x xs =
//    fold (fun (s,x) y -> let y = unboxVal y
//                         (s && Dynamic.ApplyBinaryOp(name, x, y):?>bool, y))
//         (true, unboxVal x)
//         xs

//  // requires no arguments or more
//  let addNativeBinaryFun name exprType defaultValue =
//    Dynamic.AddBinaryOp(name, exprType)
//    let defaultValue = Val defaultValue
//    addNativeFun name (function
//                        | x::xs -> Val (foldBinary name x xs)
//                        | _ -> defaultValue)
//  // requires one argument or more
//  let addNativeBinaryFun1 name exprType init =
//    Dynamic.AddBinaryOp(name, exprType)
//    addNativeFun name (function
//                        | x::Nil -> Val (Dynamic.ApplyBinaryOp(name, init, unboxVal x))
//                        | x::xs  -> Val (foldBinary name x xs)
//                        | _      -> raiseArgError tooFewParamsFun)
//
//  // requires one argument or more, returns generalised boolean
//  let addNativeBinaryFunB name exprType =
//    Dynamic.AddBinaryOp(name, exprType)
//    addNativeFun name (function
//                        | x::Nil -> T
//                        | x::xs  -> let s, _ = foldBinaryBool name x xs
//                                    if s then T else Nil
//                        | _      -> raiseArgError tooFewParamsFun)

  let initRootEnvironment () =
    constant "NIL" (Id "NIL")
    constant "T" (Id "T")
    specialOp "IF" ``if``
    specialOp "QUOTE" quote
    specialOp "SETQ" setq
    specialOp "PROGN" Eval.progn
//    specialOp "PROGV" progv
    specialOp "LET" (``let`` true)
    specialOp "LET*" (``let`` false)
    specialOp "FLET" (flet FletType.Flet)
    specialOp "LABELS" (flet FletType.Labels)
    specialOp "MACROLET" (flet FletType.Macrolet)
    specialOp "BLOCK" block
    specialOp "RETURN-FROM" ``return-from``
    specialOp "UNWIND-PROTECT" ``unwind-protect``
    specialOp "THROW" throw
    specialOp "CATCH" catch

    nativeFunction<Func<SExpr,SExpr>> "CAR" "X"
    nativeFunction<Func<SExpr,SExpr>> "CDR" "X"
    nativeFunction<Func<SExpr,SExpr,SExpr>> "CONS" "X Y"
    nativeFunction<Func<SExpr,SExpr>> "LIST" "&REST ARGS"
    nativeFunction<Func<SExpr,SExpr>> "ATOM" "X"
    nativeFunction<Func<IDynamicEnvironment,SExpr,SExpr>> "EVAL" "X"
    nativeFunction<Func<SExpr,SExpr,SExpr>> "+" "X Y"
    nativeFunction<Func<SExpr,SExpr,SExpr>> "-" "X Y"
    nativeFunction<Func<SExpr,SExpr,SExpr>> "*" "X Y"
    nativeFunction<Func<SExpr,SExpr,SExpr>> "/" "X Y"
    nativeFunction<Func<SExpr,SExpr,SExpr>> "=" "X Y"
    nativeFunction<Func<SExpr,SExpr,SExpr>> "/=" "X Y"
    nativeFunction<Func<SExpr,SExpr,SExpr>> "EQ" "X Y"

//    addNativeBinaryFun  "+" ExpressionType.Add 0
//    addNativeBinaryFun1 "-" ExpressionType.Subtract 0
//    addNativeBinaryFun  "*" ExpressionType.Multiply 1
//    addNativeBinaryFun1 "/" ExpressionType.Divide 1
//    addNativeBinaryFunB "=" ExpressionType.Equal
//    addNativeBinaryFunB "<" ExpressionType.LessThan
//    addNativeBinaryFunB "<=" ExpressionType.LessThanOrEqual    
//    addNativeBinaryFunB ">" ExpressionType.GreaterThan
//    addNativeBinaryFunB ">=" ExpressionType.GreaterThanOrEqual
